home *** CD-ROM | disk | FTP | other *** search
- {******************************************************************************}
- { }
- { TGmGridPrint 2.3 }
- { }
- { Copyright (c) 2001 Graham Murt - www.MurtSoft.com }
- { }
- { Feel free to e-mail me with any comments, suggestions, bugs or help at: }
- { }
- { graham@murtsoft.com }
- { }
- {******************************************************************************}
-
- unit GmGridPrint;
-
- interface
-
- uses
- Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
- GmPreview, GmTypes, grids;
-
- const
- TEXT_SPACE = 100;
-
- type
- TGmDrawCellEvent = procedure (Sender: TObject; Col, Row: Longint; Rect: TRect; ACanvas: TGmCanvas) of object;
- TGmGridNewPageEvent = procedure (Sender: TObject; var ATop: TGmValue) of object;
-
- TGmGridPrint = class(TComponent)
- private
- FMonochrome: Boolean;
- FScale: Extended;
- FScaleText: Boolean;
- FPreview: TGmPreview;
- FStringGrid: TStringGrid;
- FOnDrawCell: TGmDrawCellEvent;
- FOnGridNewPage: TGmGridNewPageEvent;
- procedure DrawLeftTopBorder(ACanvas: TGmCanvas; ARect: TRect);
- procedure DrawRightBorder(ACanvas: TGmCanvas; ARect: TRect);
- procedure DrawBottomBorder(ACanvas: TGmCanvas; ARect: TRect);
- { Private declarations }
- protected
- procedure DrawCell(Sender: TObject; Col, Row: Longint; Rect: TRect; ACanvas: TGmCanvas); virtual;
-
- procedure GotoNextPage;
- procedure Notification(AComponent: TComponent; Operation: TOperation); override;
-
- function GetGridWidth: integer;
- function GetCellRect(GridLeft, GridTop: Integer; ACol, ARow: integer; AScale: Extended): TRect;
- { Protected declarations }
- public
- constructor Create(AOwner: TComponent); override;
- procedure GridToPage(X, Y, AWidth: Extended; AUnits: TGmMeasurement;
- AGrid: TStringGrid);
- { Public declarations }
- published
- { Published declarations }
- property Monochrome: Boolean read FMonochrome write FMonochrome default False;
- property Preview: TGmPreview read FPreview write FPreview;
- property ScaleText: Boolean read FScaleText write FScaleText default True;
- // events...
- property OnDrawCell: TGmDrawCellEvent read FOnDrawCell write FOnDrawCell;
- property OnGridNewPage: TGmGridNewPageEvent read FOnGridNewPage write FOnGridNewPage;
- end;
-
- implementation
-
- uses GmErrors, Dialogs;
-
- constructor TGmGridPrint.Create(AOwner: TComponent);
- begin
- inherited;
- FMonochrome := False;
- FScaleText := True;
- end;
-
- procedure TGmGridPrint.Notification(AComponent: TComponent; Operation: TOperation);
- begin
- inherited Notification(AComponent, Operation);
- if (Operation = opRemove) and (AComponent = FPreview) then
- FPreview := nil;
- end;
-
- procedure TGmGridPrint.GotoNextPage;
- begin
- if FPreview.CurrentPage < FPreview.NumPages then
- FPreview.CurrentPage := FPreview.CurrentPage+1
- else
- FPreview.NewPage;
- end;
-
- function TGmGridPrint.GetGridWidth: integer;
- var
- ICountX: integer;
- begin
- Result := 0;
- for ICountX := 0 to FStringGrid.ColCount-1 do
- Inc(Result, FStringGrid.ColWidths[ICountX]);
- Result := Round(ConvertValue(Result, GmPixels, GmUnits));
- end;
-
- function TGmGridPrint.GetCellRect(GridLeft, GridTop: Integer; ACol, ARow: integer; AScale: Extended): TRect;
- var
- CellWidth, CellHeight: integer;
- begin
- Result.Left := 0;
- Result.Top := 0;
-
- CellWidth := Round(ConvertValue(FStringGrid.ColWidths[ACol], GmPixels, GmUnits));
- CellHeight := Round(ConvertValue(FStringGrid.RowHeights[ARow], GmPixels, GmUnits));
-
- Result.Left := GridLeft;
- Result.Top := GridTop;
- Result.Right := GridLeft + Round(CellWidth * AScale);
- Result.Bottom := GridTop + Round(CellHeight);
- end;
-
- procedure TGmGridPrint.DrawLeftTopBorder(ACanvas: TGmCanvas; ARect: TRect);
- begin
- with ACanvas do
- begin
- Pen.Color := clBlack;
- MoveTo(ARect.Left, ARect.Bottom, GmUnits);
- LineTo(ARect.Left, ARect.Top, GmUnits);
- LineTo(ARect.Right, ARect.Top, GmUnits);
- end;
- end;
-
- procedure TGmGridPrint.DrawRightBorder(ACanvas: TGmCanvas; ARect: TRect);
- begin
- with ACanvas do
- begin
- Pen.Color := clBlack;
- MoveTo(ARect.Right, ARect.Bottom, GmUnits);
- LineTo(ARect.Right, ARect.Top, GmUnits);
- end;
- end;
-
- procedure TGmGridPrint.DrawBottomBorder(ACanvas: TGmCanvas; ARect: TRect);
- begin
- with ACanvas do
- begin
- Pen.Color := clBlack;
- Line(ARect.Left, ARect.Bottom, ARect.Right, ARect.Bottom, GmUnits);
- end;
- end;
-
- procedure TGmGridPrint.GridToPage(X, Y, AWidth: Extended; AUnits: TGmMeasurement;
- AGrid: TStringGrid);
- var
- GridLeft,GridTop: integer;
- ICountX, ICountY: integer;
- ARect: TRect;
- PrintWidth: Extended;
- CurrentYPos: Integer;
- CurrentXPos: Integer;
- YValue: TGmValue;
- LastPen: TPen;
- begin
- FStringGrid := AGrid;
- if Assigned(FPreview) then
- begin
- LastPen := TPen.Create;
- LastPen.Assign(FPreview.Canvas.Pen);
- FPreview.MessagesEnabled := False;
- // get the print scale...
- if AWidth <> 0 then
- begin
- PrintWidth := Round(ConvertValue(AWidth, AUnits, GmUnits));
- FScale := PrintWidth / GetGridWidth;
- end
- else
- FScale := 1;
- GridLeft := Round(ConvertValue(X, AUnits, GmUnits));
- GridTop := Round(ConvertValue(Y, AUnits, GmUnits));
-
- CurrentYPos := GridTop;
- CurrentXPos := GridLeft;
- for ICountY := 0 to FStringGrid.RowCount-1 do
- begin
- for ICountX := 0 to FStringGrid.ColCount-1 do
- begin
- ARect := GetCellRect(CurrentXPos, CurrentYPos, ICountX, ICountY, FScale);
- with FPreview.Canvas do
- begin
- DrawCell(Self, ICountX, ICountY, ARect, FPreview.Canvas);
-
- DrawLeftTopBorder(FPreview.Canvas, ARect);
- if ICountX = FStringGrid.ColCount-1 then DrawRightBorder(FPreview.Canvas, ARect);
-
- if ICountY = FStringGrid.RowCount-1 then DrawBottomBorder(FPreview.Canvas, ARect);
-
- end;
- Inc(CurrentXPos, ARect.Right-ARect.Left);
- if ICountX = FStringGrid.ColCount-1 then CurrentXPos := GridLeft;
- end;
-
- Inc(CurrentYPos, ARect.Bottom-ARect.Top);
-
- if CurrentYPos > (FPreview.PageHeight.AsUnits - (FPreview.Margins.Bottom.AsUnits + +FPreview.Header.Height.AsUnits + 1000)) then
- begin
- if ICountY < FStringGrid.RowCount-1 then
- begin
- DrawBottomBorder(FPreview.Canvas, Rect(GridLeft, ARect.Bottom, ARect.Right, ARect.Bottom));
- GotoNextPage;
- CurrentYPos := GridTop;
- if Assigned(FOnGridNewPage) then
- begin
- YValue := TGmValue.Create;
- FOnGridNewPage(Self, YValue);
- if YValue.AsUnits <> 0 then CurrentYPos := YValue.AsUnits;
- YValue.Free;
- end;
- end;
- end;
- end;
- FPreview.Canvas.Pen.Assign(LastPen);
- LastPen.Free;
- FPreview.MessagesEnabled := True;
- FPreview.UpdatePreview;
- end
- else
- ShowGmError(Self, PREVIEW_NOT_ASSIGNED);
- end;
-
- procedure TGmGridPrint.DrawCell(Sender: TObject; Col, Row: Longint; Rect: TRect; ACanvas: TGmCanvas);
- var
- LastPenColor: TColor;
- LastPpi: integer;
- begin
- LastPpi := ACanvas.Font.PixelsPerInch;
- ACanvas.Font.Assign(FStringGrid.Font);
- if Assigned(FOnDrawCell) then
- with ACanvas do
- begin
- if (FScale < 1) and (FScaleText) then Font.PixelsPerInch := Round(Font.PixelsPerInch / FScale);
- Pen.Style := psClear;
- FOnDrawCell(Self, Col, Row, Rect, FPreview.Canvas);
- Pen.Style := psSolid;
- ACanvas.Font.PixelsPerInch := LastPpi;
- end
- else
- begin
- with ACanvas do
- begin
- if (Col <= FStringGrid.FixedCols-1) or (Row <= FStringGrid.FixedRows-1) then
- ACanvas.Brush.Color := FStringGrid.FixedColor
- else
- ACanvas.Brush.Color := FStringGrid.Color;
- LastPenColor := Pen.Color;
- Pen.Color := Brush.Color;
- if FMonochrome then
- begin
- Brush.Style := bsClear;
- Pen.Style := psClear;
- end;
- Rectangle(Rect.Left,
- Rect.Top,
- Rect.Right,
- Rect.Bottom,
- GmUnits);
- Pen.Color := LastPenColor;
- Pen.Style := psClear;
- if (FScale < 1) and (FScaleText) then Font.PixelsPerInch := Round(Font.PixelsPerInch / FScale);
- TextBoxExt(Rect.Left+TEXT_SPACE,
- Rect.Top,
- Rect.Right,
- Rect.Bottom,
- FStringGrid.Cells[Col, Row], taLeftJustify, gmMiddle, True, GmUnits);
- Font.PixelsPerInch := LastPpi;
- Pen.Style := psSolid;
- Brush.Style := bsSolid;
- end;
- end;
- end;
-
-
- end.
-